perm filename FASLOA[MAC,LSP]1 blob
sn#287422 filedate 1977-06-08 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00027 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00002 00002 IFN SAIL,[
C00007 00003
C00008 00004
C00012 00005
C00015 00006
C00018 00007
C00022 00008
C00024 00009
C00027 00010
C00031 00011
C00034 00012
C00037 00013
C00039 00014
C00042 00015
C00043 00016
C00045 00017
C00048 00018
C00051 00019
C00053 00020
C00056 00021
C00058 00022
C00060 00023
C00061 00024
C00063 00025
C00065 00026
C00067 00027
C00071 ENDMK
C⊗;
IFN SAIL,[
SAIFNB==6
SAIFBF: BLOCK SAIFNB*200
SAIFPT: SAIFBF
SAIFN: 0
SAIFSKP: 0
SAIFDW: -<N*200>,,SAIFBF
0
SAIFUN: 0
] ;END OF IFN SAIL
;;; **************************************************************
;;; ***** MACLISP ****** FASLOAD ********************************
;;; **************************************************************
;;; ** (C) COPYRIGHT 1977 MASSACHUSETTS INSTITUTE OF TECHNOLOGY **
;;; ****** THIS IS A READ-ONLY FILE! (ALL WRITES RESERVED) *******
;;; **************************************************************
PGBOT FSL
SUBTTL HAIRY RELOCATING LOADER (FASLOAD)
;;; BUFFER PARAMETERS
Q% 10% LLDBF==100 ;LENGTH OF LOADER'S BINARY INPUT BUFFER ARRAY
Q% 10$ LLDBF==201
LLDAT==770 ;LENGTH OF LOADER'S ATOMTABLE ARRAY
ILDAT==1000 ;AMOUNT TO INCREMENT ATOMTABLE ARRAY
LLDSTB==400 ;SIZE OF LDPUT'S SYMBOL TABLE ARRAY (IN 2-WD ENTRIES)
;;; PDL OFFSETS
IFE QIO,[
LDAGEN==0 ;SAR FOR ATOMTABLE
LDBGEN==-1 ;SAR FOR I/O BUFFER
LDPRLS==-2 ;PURE CLOBBERING LIST
LDDDTP==-3 ;DDT FLAG
] ;END OF IFE QIO,
.ELSE,[
LDAGEN==0 ;SAR FOR ATOMTABLE
LDPRLS==-1 ;PURE CLOBBERING LIST
LDDDTP==-2 ;DDT FLAG
LDBGEN==-3 ;SAR FOR I/O BUFFER
] ;END OF .ELSE,
LDNPDS==4 ;NUMBER OF REGPDL SLOTS TAKE UP BY FASLOAD TEMPORARIES
;;; FASLOAD USES AN ARRAY OF ATOMS TO AVOID CONSTANTLY CREATING
;;; THE SAME ATOMS OVER AND OVER; IN PARTICULAR, THIS SAVES MUCH
;;; TIME IN INTERN FOR ATOMIC SYMBOLS. THIS TABLE IS CREATED
;;; INCREMENTALLY DURING THE LOAD FROM DATA IN THE FASL FILE.
;;; THE ARRAY HAS ONE ONE-WORD ENTRY FOR EACH ATOM. ENTRY 0 IS
;;; FOR NIL; THE OTHERS MAY BE IN ANY ORDER. THE FORMAT OF EACH
;;; ATOMTABLE ENTRY IS AS FOLLOWS:
;;; 4.9-4.1 IF NON-ZERO, THE THE LEFT HALF OF THE ENTRY
;;; (4.9-3.1) CONTAINS THE ADDRESS OF THE VALUE
;;; CELL OF THE ATOM (SYMBOLS ONLY). THIS WORKS
;;; BECAUSE ALL VALUE CELLS ARE ABOVE ADDRESS 777.
;;; NOTE THAT OTHER LEFT HALF BITS DESCRIBED HERE
;;; HAVE MEANING ONLY IF BITS 4.9-4.1 ARE ZERO.
;;; 3.4 THIS BIT IS TURNED ON IF THE ATOM IS PROTECTED
;;; FROM THE GARBAGE COLLECTOR BECAUSE IT IS POINTED
;;; BY SOME LIST STRUCTURE WHICH IS PROTECTED. THIS
;;; IS A HACK SO THAT USELESS ENTRIES WON'T BE MADE
;;; IN THE GC PROTECTION ARRAY (SEE GCPRO).
;;; 3.3-3.2 INDICATES THE TYPE OF ATOM: 0 => SYMBOL,
;;; 1 => FIXNUM, 2 => FLONUM, 3 => BIGNUM.
;;; 3.1 THIS BIT IS TURNED ON IF THE ATOM IS EVER
;;; REFERENCED, DIRECTLY OR INDIRECTLY, BY COMPILED
;;; CODE (IT MIGHT NOT BE IF USED ONLY IN MUNGABLES).
;;; IT INDICATES THAT THE ATOM MUST SOMEHOW BE
;;; PROTECTED FROM THE FEROCIOUS GARBAGE COLLECTOR.
;;; 2.9-1.1 CONTAINS THE ADDRESS OF THE ATOM. (SURPRISE!)
;;; NOTE THAT ONCE AN ATOM IS IN THE TABLE, THE FASL FILE WILL
;;; REFER TO THE ATOM BY ITS TABLE INDEX, SO THAT IT CAN BE
;;; RETRIEVED EXTREMELY QUICKLY.
;;; INTERNAL AUTOLOAD ROUTINE
IFE QIO,[
IALB: HRRZ C,(A)
HLRZ A,IRACOM
HRRZ B,@IUNIT
PUSHJ P,CONS
JSP T,SPECBIND
0 A,IUNIT
NW% SAVEFX UFN1 UFN2
MOVEI A,(C) ;INTERNAL AUTOLOAD BREAK IS ESSENTIALLY FASLOAD
PUSHJ P,FASLOAD
NW% RSTRFX UFN2 UFN1
JRST UNBIND
] ;END OF IFE QIO
IFN QIO,[
IALB: HRRZ AR2A,VDEFAULTF ;SUBR 1
JSP T,SPECBIND
0 AR2A,VDEFAULTF
HRRZ A,(A)
MOVEI B,QCOMDEV
PUSHJ P,MERGEF
PUSHJ P,LOAD
JRST UNBIND
] ;END OF IFN QIO
FASLOAD: JSP TT,FWNACK
FA01234,,QFASLOAD
SKIPE FASLP
JRST LDALREADY
PUSH P,FLP ;FOR DEBUGGING PURPOSES
PUSH P,FXP .SEE LDEOMM
PUSH P,SP
IFN SAIL,[
SETZM SAILFL ;FLAG FOR SAIL DUMP MODE IO
SETZM SAIFN ;FLAGS FOR SAIL DUMP MODE IO
SETZM SAIFSK ;CACHE HACK
SETZM SAIFUN ;SUPER TEMPORARY HACK UNTIL NEWIO
] ;END OF IFN SAIL
IFE QIO,[
AOJN T,LDXXX7
HLRZ A,(A)
MOVEI B,QFASLL
PUSHJ P,CONS
LDXXX7: MOVEM A,LDFNAM
] ;END OF IFE QIO
IFN QIO,[
PUSHJ P,FIL6BT
MOVSI T,(SIXBIT \*\)
10% MOVE TT,[SIXBIT \FASL\] ;DEFAULT SECOND FILE NAME IS "FASL"
10$ MOVSI TT,(SIXBIT \FAS\) ;DEFAULT FILE NAME EXTENSION IS "FAS"
CAMN T,(FXP)
MOVEM TT,(FXP)
PUSHJ P,DMRGF
PUSHJ P,6BTNML
] ;END OF IFN QIO
MOVEI B,TRUTH
JSP T,SPECBIND
Q$ 0 A,LDFNAM ;QIO MUST BIND LDFNAM FOR POSSIBLE RECURSIVE FASLOAD
0 B,VNORET
Q% 0 B,FASLP
Q$ FASLP
IFE QIO,[
PUSH P,IUNIT
MOVEI T,6 ;OPEN FASL FILE IN BLOCK IMAGE MODE
PUSHJ P,UINITA
10% .OPEN DSIC,UTIN
10% JRST LDOERR
IFN D10,[
MOVEI T,16
SETZ T+2,
PUSHJ P,LDOPN1 ;USE COMMON OPEN
JRST LDOERR ;USE LOAD ERROR MESSAGE
LOOKUP DSIC,T
JRST LDOERR ;SAME MESSAGE
SETZM D10PTR
] ;END OF IFN D10
SUB P,R70+1 ;SUB OFF OLD IUNIT
UNLOCKI
PUSHJ P,LDFNSET
MOVEM A,LDFNAM
] ;END OF IFE QIO
IFN QIO,[
PUSH P,[LDXXY1]
PUSH P,A
PUSH P,[QFIXNUM]
MOVNI T,2
JRST $OPEN
LDXXY1: MOVEM A,FASLP
PUSH P,A
HRRZM A,LDBSAR
MOVE A,LDFNAM
PUSHJ P,DEFAULTF
SETZM LDTEMP ;CROCK!
] ;END OF IFN QIO
LDDISM: PUSHJ P,LDGDDT ;SET UP DDT FLAG: 0 => NO DDT;
PUSH P,TT ;-1,,0 => DDT, NO SYMBOLS; 1,,X => DDT, SYMBOLS
; ;X MAY BE 0, OR SAR FOR SYMBOL TABLE ARRAY (SEE LDPUT)
SKIPN F,VPURE ;SET UP CALL PURIFY FLAG:
; ;400000,,XXX => NO PURIFY HACKERY
TLOA F,400000 ;200000,,XXX => SUBST XCTS FOR CALLS, PUT CALLS IN SEPARATE PAGES
HRRZ F,VPURCLOBRL ;0,,<PURE LIST> => SUBST PUSHJS AND JRSTS FOR CALLS;
PUSH P,F ; ANY CALLS NOT IMMEDIATELY SMASHABLE
MOVE A,VPURE ; ARE CONSED ONTO THE PURE LIST
PUSHJ P,FIXP ;LEAVES VALUE IN TT IF INDEED FIXNUM
JUMPE A,LDXXX1
MOVSI F,200000
IORM F,(P)
PUSHJ P,LDXHAK ;SET UP XCT HACK PAGES
;FALLS THROUGH
;FALLS IN
LDXXX1:
IFE QIO,[ HRRZ B,FASLP ;FASLP IS T FIRST TIME, ELSE
CAIE B,TRUTH ; SAR OF I/O BUFFER ARRAY
JRST LDXXX8
SETZM LDTEMP
MOVEI TT,LLDBF ;CREATE I/O BUFFER ARRAY
MOVSI A,400000
PUSHJ P,MKFXAR
HRRZM B,LDBSAR ;SAVE ADDRESS OF SAR
MOVEM B,FASLP
LDXXX8: PUSH P,B ;SAVE SAR FOR I/O BUFFER [FROM GC]
] ;END OF IFE QIO
MOVE TT,[-LLDAT+1,,1] ;INIT ATOMTABLE AOBJN INDEX
MOVEM TT,LDAAOB
MOVEI TT,LLDAT ;CREATE ATOMTABLE ARRAY
MOVSI A,400000
PUSHJ P,MKLSAR
PUSH P,A ;SAVE SAR OF ATOM-TABLE ARRAY FOR GC PROTECTION
HRRZM B,LDASAR ;SAVE ADDRESS OF SAR
PUSHJ P,LDLRSP ;LOCKI, AND SET UP ARRAY POINTERS
SETZ TT, ;ENTRY 0 IN ATOMTABLE IS FOR NIL
SETZM @LDAPTR
MOVEI TT,LDFERR ;INIT ADDRESS FOR PREMATURE EOF
MOVEM TT,LDEOFJ
SKIPE F,LDTEMP ;IF LDTEMP IS NON-NIL, IT IS THE SAVED I/O BUFFER POINTER
JRST LDXXX9
JSP T,LDGTW1 ;GET FIRST WORD OF FILE
TRZ TT,1 ;COMPATIBILITY CROCK
CAME TT,[SIXBIT \*FASL*\] ;IT BETTER BE THIS VALUE!
JSP D,LDFERR
LDXXX9: JSP T,LDGTWD ;GET VERSION OF LISP FILE WAS ASSEMBLED IN
XOR TT,LDFNM2
MOVEM TT,LDF2DP ;NON-ZERO IFF VERSIONS DIFFERENT
MOVE TT,@VBPORG ;INIT LOAD OFFSET
HRRM TT,LDOFST
MOVE AR1,[000400,,LDBYTS] ;INIT RELOCATION BYTES POINTER
SETZM LDHLOC
JRST LDABS0
SUBTTL ROUTINE TO SET UP PAGES FOR XCT HACK
;;; TT HAS NUMBER OF PAGES DESIRED.
LDXHAK: SKIPE LDXSIZ ;MAYBE WE NEED TO SET UP PAGES FOR XCT HACKERY
POPJ P,
SKIPLE TT ;CHECK NUMBER OF PAGES REQUESTED
CAILE TT,10
JRST LDXERR
PUSH FXP,TT
PUSHJ P,PAGEBPORG ;ADJUST BPORG TO BEGINNING OF PAGE
MOVE D,(FXP)
LSH D,PAGLOG ;CONVERT BLOCK COUNT TO WORDS
MOVEM D,LDXSIZ ;SAVE AS SIZE OF XCT AREA
MOVEM D,LDXSM1 ;ALSO NEED THAT VALUE MINUS 1
SOS LDXSM1
MOVE TT,@VBPORG ;CREATE TWO AREAS IN BPS THAT BIG:
HRRZ T,TT ; THE FIRST FOR THE XCTS TO POINT TO,
ADD TT,D ; THE SECOND TO RESTORE THE FIRST FROM
HRL T,TT
MOVEM T,LDXBLT ;SAVE BLT POINTER FOR RESTORING
ADD TT,D
JSP T,FIX1A ;NEW VALUE FOR BPORG
PUSH P,A
LSH D,1 ;NOW TRY TO GET REQUIRED CORE
MOVE TT,D
PUSHJ P,LGTSPC
JUMPE TT,FASLNX
POP P,VBPORG ;GIVE BPORG NEW VALUE
IFN ITS,[
HLLOS NOQUIT ;MUST UPDATE PURTBL ENTRIES
HRRZ T,LDXBLT ; FOR XCT HACK PAGES
ROT T,-PAGLOG-4 ;COMPUTE BYTE POINTER
ADDI T,(T)
ROT T,-1
TLC T,770000
ADD T,[450200,,PURTBL]
MOVE F,[-2,,1] ;WANT TO DO IMPURE PAGES,
SKIPA D,(FXP) ; THEN PURE PAGES
LDXXX3: POP FXP,D ;SECOND TIME THROUGH POP FXP
LDXXX0: TLNN T,730000 ;DEPOSIT BYTE FOR NEXT PAGE
TLZ T,770000
IDPB F,T
SOJG D,LDXXX0 ;COUNT OFF PAGES
AOBJN F,LDXXX3 ;LOOP BACK TO DO PURE PAGES
PUSHJ P,CZECHI
] ;END OF IFN ITS
MOVE T,LDXBLT ;ZERO OUT BOTH AREAS
MOVE TT,@VBPORG
HRL T,T
SETZM (T)
ADDI T,1
BLT T,-1(TT)
JRST TRUE
SUBTTL MAIN FASLOAD LOOP
;;; FROM THIS POINT ON, UNTIL A FATAL ERROR OCCURS OR LOCATION LDFEND IS REACHED,
;;; THESE ACCUMULATORS ARE DEDICATED TO THE FOLLOWING PURPOSES:
;;; AR1 BYTE POINTER FOR GETTING SUCCESSIVE RELOCATION TYPES
;;; R AOBJN POINTER FOR PUTTING WORDS INTO BINARY PROGRAM SPACE
;;; F AOBJN INDEX FOR ACCESSING WORDS FROM INPUT BUFFER ARRAY
LDREL: HRRI TT,@LDOFST ;[RELOCATABLE WORD]
LDABS: MOVEM TT,(R) ;[ABSOLUTE WORD]
LDABS1: AOBJN R,LDBIN ;JUMP IF ROOM LEFT OF WHAT WE GRABBED
LDABS0: MOVE R,@VBPORG
PUSHJ P,LDGTSP
PUSHJ P,LDRSPT
LDBIN: SKIPE INTFLG ;[LOAD BINARY WORD (OR SOME OTHER MESS)]
PUSHJ P,LDTRYI ;GIVE A POOR INTERRUPT A CHANCE IN LIFE
TLNN AR1,770000
JRST LDBIN2 ;OUT OF RELOCATION BYTES - MUST GET MORE
LDBIN1: JSP T,LDGTWD ;GET WORD FROM INPUT FILE
ILDB T,AR1 ;GET CORRESPONDING RELOCATION BYTE
JSP D,@LDTTBL(T) ; - IT TELLS US WHERE TO GO
LDBIN2: JSP T,LDGTWD ;GET WORD OF RELOCATION BYTES
MOVEM TT,LDBYTS
SOJA AR1,LDBIN1 ;INIT BYTE POINTER AND GO GET DATA WORD
LDTTBL: LDABS ; 0 ABSOLUTE
LDREL ; 1 RELOCATABLE
LDSPC ; 2 SPECIAL
LDPRC ; 3 PURIFIABLE CALL
LDQAT ; 4 QUOTED ATOM
LDQLS ; 5 QUOTED LIST
LDGLB ; 6 GLOBALSYM PATCH
LDGET ; 7 GET DDT SYMBOL PATCH
LDAREF ; 10 ARRAY REFERENCE
LDFERR ; 11 UNUSED
LDATM ; 12 ATOMTABLE ENTRY
LDENT ; 13 ENTRY POINT INFO
LDLOC ; 14 LOC TO ANOTHER PLACE
LDPUT ; 15 PUT DDT SYMBOL
LDEVAL ; 16 EVALUATE MUNGEABLE
LDBEND ; 17 END OF BINARY
;;; R MUST BE SET UP ALREADY
LDGTSP: MOVE TT,@VBPEND ;SEE IF ENOUGH ROOM LEFT TO GRAB MORE
SUB TT,@VBPORG
SUBI TT,100 ;RANDOMLY CHOSEN QUANTITY
JUMPGE TT,LDGSP1 ;YES - GO GRAB IT
SAVEFX AR1 D R F
MOVEI TT,4*PAGSIZ ;GET MANY BLOCKS OF BPS
LDGS0A: MOVEM TT,GAMNT
PUSHJ P,GTSPC1
JUMPN TT,LDGS0H
MOVE TT,GAMNT
CAIG TT,100
JRST FASLNC
MOVEI TT,100
JRST LDGS0A
LDGS0H: RSTRFX F R D AR1
LDGSP1: MOVEI TT,(R)
ADDI TT,PAGSIZ ;TRY TO GOBBLE <PAGSIZ>
CAMLE TT,@VBPEND ; WORDS, BUT IN ANY CASE
MOVE TT,@VBPEND ; NO MORE THAN BEYOND BPEND
JSP T,FIX1A
MOVEM A,VBPORG
MOVEI TT,(R)
SUB TT,@VBPORG
HRLI R,(TT) ;INIT AOBJN POINTER IN R
POPJ P,
SUBTTL SPECIAL VALUE CELL AND QUOTED ATOM REFERENCES
LDSPC: MOVE T,TT ;[SPECIAL]
HLR TT,@LDAPTR ;GET ADDRESS OF SPECIAL CELL
TRNE TT,777000 ;WAS SUCH AN ADDRESS REALLY THERE?
JRST LDABS ;YES, WIN
TRNE TT,6 ;NO, IS THIS ATOM A NUMBER
JSP D,LDFERR ;YES - LOSE!!!
HRRZ TT,T ;IS THERE AN ATOM THERE AT ALL
HRRZ A,@LDAPTR
SKIPN D,A
JSP D,LDFERR ;NO, LOSE
HLRZ B,(A)
HRRZ A,(B)
CAIE A,SUNBOUND
JRST LDSPC1
PUSH P,D ;NONE THERE - MUST MAKE ONE
MOVEI B,QUNBOUND
JSP TT,MAKVC
LDSPC1: MOVE TT,T ;SAVE ADDRESS OF VALUE CELL
HRLM A,@LDAPTR ; IN ATOMTABLE
HRR TT,A ;AT LAST WE WIN
JRST LDABS
LDQAT: MOVE D,@LDAPTR ;[QUOTED ATOM]
TLNN D,777001 ;SKIP IF SPECIAL OR ALREADY USED
TLO D,1 ;ELSE TURN ON REFERENCE BIT
MOVEM D,@LDAPTR
HRRI TT,(D) ;GET ADDRESS OF ATOM
JRST LDABS
SUBTTL QUOTED LIST REFERENCES
LDQLS: MOVSI D,11 ;[QUOTED LIST]
SKIPL LDPRLS(P) ;CAN'T COUNT ON ANYTHING IN PURE
MOVSI D,1 ; FREE STORAGE PROTECTING ANYTHING
PUSHJ P,LDLIST ;GOBBLE UP A LIST
MOVEM TT,(R) ;PUT WORD IN BPS
JSP T,LDGTWD ;GET HASH KEY FOR LIST
TLZ A,-1
SKIPE VGCPRO
JRST LDQLS4
PUSH FXP,D
PUSH FXP,AR1
TLZ A,-1
SKIPE D,TT
JRST LDQLS3
PUSH P,A
PUSHJ P,SXHSH0
POP P,A
LDQLS3: SKIPN V.PURE ;SKIP FOR PURE HACKERY
JRST LDQLS1
PUSH FXP,D ;SAVE HASH KEY
PUSH P,A ;SAVE LIST
MOVNI T,1 ;THIS MEANS JUST LOOKUP
PUSHJ P,LDGPRO
POP P,B
POP FXP,D
JUMPN A,LDQLS2 ;ON GCPRO LIST, SO USE IT
MOVE A,B
PUSHJ P,PURCOPY ;NOT ON GCPRO LIST, SO PURCOPY IT
LDQLS1: MOVEI T,1 ;THIS MEANS PROTECT OR HAND BACK COPY
PUSHJ P,LDGPRO ;PROTECT LIST FROM FEROCIOUS GC!
LDQLS2: POP FXP,AR1
POP FXP,D
LDQLS5: JUMPE D,LDEVL7 ;MAYBE THIS LIST GOES INTO ATOMTABLE
HRRM A,(R) ;SAVE ADDRESS OF LIST (WHICH MAY
JRST LDABS1 ; BE DIFFERENT NOW) BACK INTO WORD
LDQLS4: JSP T,LDQLPRO
JRST LDQLS5
LDQLPRO: HRRZ B,LDEVPRO ;GC-PROTECTON IS ACCOMPLISHED MERELY BY PUSHING ONTO A LIST
PUSHJ P,CONS
MOVEM A,LDEVPRO
JRST %CAR
LDGPRO: SKIPE GCPSAR ;PROTECT SOMETHING ON THE GCPSAR
JRST .GCPRO
PUSHJ P,.GCPRO ;FOO, THE LOOKUP WILL CAUSE THE CREATION OF A NEW ARRAY
JRST LDRSPT ;SO WE HAVE TO RESTORE PTRS AFTERWARDS
SUBTTL PURIFIABLE CALL
LDPRC: MOVE D,@LDAPTR ;[PURIFIABLE CALL]
TLNE D,777000
JRST LDPRC1 ;JUMP IF ATOM HAS SPECIAL CELL
TLNE D,6
JSP D,LDFERR ;LOSE IF NUMBER
TLO D,1 ;ELSE TURN ON REFERENCE BIT
MOVEM D,@LDAPTR
LDPRC1: TRNN D,-1 ;MUST HAVE NON-NIL ATOM TO CALL
JSP D,LDFERR
HRR TT,D ;PUT ADDRESS OF ATOM IN CALL
SKIPGE T,LDPRLS(P) ;SKIP FOR PURIFYING HACKERY
JRST LDABS ;OTHERWISE WE'RE DONE
TLNN T,200000 ;SKIP FOR XCT STUFF
SETZ T, ;ELSE DO ORDINARY SMASH
PUSHJ P,PRCHAK ;*** SMASH! ***
JRST LDABS1
MOVEI A,(R) ;NOT SMASHED - CONS ONTO PURE LIST
MOVE B,LDPRLS(P)
PUSHJ P,CONS
MOVEM A,LDPRLS(P)
JRST LDABS1
;;; ROUTINE TO CLOBBER A CALL INTO BPS, POSSIBLY DOING XCT HACK.
;;; SKIPS ON *** FAILURE *** TO CLOBBER.
;;; T NON-ZERO => TRY XCT HACK; OTHERWISE ORDINARY SMASH.
;;; TT HAS UUO INSTRUCTION TO HACK.
;;; R HAS ADDRESS TO PUT UUO INTO.
;;; MUST PRESERVE AR1, R, F.
PRCHAK: JUMPE T,LDPRC5 ;T ZERO => ORDINARY SMASH
MOVE T,TT ;SAVE CALL IN T
IDIV TT,LDXSM1 ;COMPUTE HASH CODE FOR CALL
MOVNM D,LDTEMP ;SAVE NEGATIVE THEREOF
HLRZ TT,LDXBLT
ADD D,TT ;ADDRESS TO BEGIN SEARCH
CAMN T,(D) ;WE MAY WIN IMMEDIATELY
JRST LDPRC7
SKIPN (D)
JRST LDPRC6
ADD TT,LDXSM1 ;ELSE MAKE UP AN AOBJN POINTER
SUBI TT,-1(D) ; AND SEARCH FOR MATCHING CALL
MOVNI TT,(TT)
HRL D,TT
LDPRC2: CAMN T,(D)
JRST LDPRC7 ;FOUND MATCHING CALL
SKIPN (D)
JRST LDPRC6 ;FOUND EMPTY SLOT
AOBJN D,LDPRC2
HRLZ D,LDTEMP ;WRAPPED OFF THE END OF THE XCT AREA
HLR D,LDXBLT ; - MAKE UP NEW AOBJN POINTER
LDPRC3: CAMN T,(D)
JRST LDPRC7 ;FOUND MATCHING CALL
SKIPN (D)
JRST LDPRC6 ;FOUND EMPTY SLOT
AOBJN D,LDPRC3
LDPRC4: MOVE TT,T ;TOTAL LOSS - MUST DO SMASH
LDPRC5: HRRZ AR2A,R ;PUT ADDRESS OF CALL IN AR2A
MOVEM TT,(AR2A) ;PUT CALL IN THAT PLACE
JRST LDSMSH ;NOW TRY TO SMASH IT, EXITING WITH SKIP ON FAILURE
LDPRC6: SKIPG TT,LDXSIZ ;FOUND EMPTY SLOT
JRST LDPRC4 ;CAN'T USE IT IF PAGES PURIFIED
MOVEM T,(D) ;SAVE CALL INTO XCT AREA 2
SUBM D,TT
MOVEM T,(TT) ;ALSO SAVE INTO AREA 1
LDPRC7: SUB D,LDXSIZ ;MAKE UP AN XCT TO POINT TO
HRLI D,(XCT) ; CALL IN AREA 1
MOVEM D,(R)
POPJ P,
LDSMSH: MOVE T,(AR2A)
MOVEI A,(T)
LSH T,-33
CAIL T,CALL←-33
CAILE T,CALL←-33+NUUOCLS
POPJ P,
HRRZ A,(AR2A) ;SMASH A CALL/JCALL - AR2A HAS LOC OF CALL
MOVEI B,SBRL ;RETURN SKIPS IF IT CAN'T BE SMASHED
PUSHJ P,GETLA ;TRY TO GET SUBR, FSUBR, OR LSUBR PROP
LDB D,[<270400,,> (AR2A)] ;DESTROYS A,B,C,T,TT,D - SAVES AR1,AR2A [ARG],R,F
JUMPE A,LDSMNS
HLRZ B,(A)
MOVE T,[CAILE D,NACS]
CAIN B,QFSUBR
MOVE T,[CAIE D,17]
CAIN B,QLSUBR
MOVE T,[CAIE D,16]
XCT T
JRST POPJ1 ;LOSE IF WRONG NUMBER OF ARGS WANTED - SKIP RETURN
HRRZ A,(A) ;ELSE WIN - SMASH THE CALL
HLRZ A,(A) ;SUBR ADDRESS NOW IN A
SKIPA TT,(AR2A)
LDZAOK: HRLI A,(@) .SEE ASAR
MOVSI T,(PUSHJ P,) ;CALL BECOMES PUSHJ
TLNE TT,20000
ADDI A,1 ;HACK NCALLS CORRECTLY
TLNE TT,1000
MOVSI T,(JRST) ;JCALL BECOMES JRST
LDZA1: IOR T,A
MOVEM T,(AR2A) ;***SMASH!***
POPJ P,
LDSMNS: HRRZ A,(AR2A) ;TRY TO GET ARRAY PROPERTY
MOVEI B,QARRAY
PUSHJ P,GET
MOVEI T,(A)
LSH T,-SEGLOG
MOVE T,ST(T)
TLNN T,SA
JRST POPJ1 ;LOSE IF NOT SAR
LDB T,[TTSDIM,,TTSAR(A)]
CAIE T,(D) ;MUST HAVE CORRECT NUMBER OF ARGS
JRST POP1J
MOVSI T,TTS<CN>
IORM T,TTSAR(A) ;SET "COMPILED-CODE-NEEDS-ME" BIT.
MOVE TT,(AR2A)
TLNN TT,20000
JRST LDZAOK
MOVSI T,(ACALL)
TLNE TT,1000
MOVSI T,(AJCALL)
JRST LDZA1
SUBTTL GETDDTSYM HACKERY
LDGET: CAMN TT,XC-1
JRST LDLHRL
MOVE D,TT ;[GET DDT SYMBOL PATCH]
TLNN D,200000 ;MAYBE THE ASSEMBLER LEFT US A VALUE?
JRST LDGET2
JSP T,LDGTWD ;FETCH IT THEN
SKIPE LDF2DP
JRST LDGET2 ;CAN'T USE IT IF VERSIONS DIFFER
LDGET1: TLNE D,400000 ;MAYBE NEGATE SYMBOL?
MOVNS TT
LDB D,[400200,,D] ;GET FIELD NUMBER
XCT LDXCT(D) ;HASH UP VALUE FOR FIELD
MOVE T,LDMASK(D) ;ADD INTO FIELD
ADD TT,-1(R) ; MASKED APPROPRIATELY
AND TT,T
ANDCAM T,-1(R)
IORM TT,-1(R)
JRST LDBIN
LDGET2: UNLOCKI ;UNLOCK INTERRUPTS
PUSH FXP,. ;RANDOM FXP SLOT
PUSH FXP,AR1 ;SAVE UP ACS
PUSH FXP,D
PUSH FXP,R
PUSH FXP,F
MOVEI R,0
TLZ D,740000
REPEAT LOG2LL5,[
CAML D,LAPFIV+<1←<LOG2LL5-.RPCNT-1>>(R)
ADDI R,1←<LOG2LL5-.RPCNT-1>
] ;END OF REPEAT LOG2LL5
CAME D,LAPFIV(R) ;IF DDTSYM REQUEST IS FOR A GLOBAL SYM
JRST LDGT5A ;THEN FIND IT IN THE LAPFIV TABLE, AND GET ITS
LSHC R,-2 ;GLOBALSYM INDEX FROM THE PERMUTATION TABLE
LSH F,-42
LDB TT,LDGET6(F)
MOVE TT,LSYMS(TT)
JRST LDGT5B
LDGT5A: MOVEI TT,R70
CAMN D,[SQUOZE 0,R70]
JRST LDGT5B
PUSHJ P,UNSQOZ ;CONVERT SQUOZE TO A LISP SYMBOL
MOVEI C,(A)
MOVEI B,QSYM ;TRY TO FIND SYM PROPERTY
PUSHJ P,GET
JUMPN A,LDGETJ ;WIN
IFN ITS,[
SKIPN LDDDTP(P) ;MAYBE WE CAN GET VALUE FROM DDT?
JRST LDGETX
LDB T,[004000,,-2(FXP)]
.BREAK 12,[..RSYM,,T]
JUMPE T,LDGETX ;LOSE, LOSE, LOSE
] ;END OF IFN ITS
IFN D10,[
SKIPN .JBSYM"
JRST LDGETX
LDB D,[004000,,-2(FXP)]
LDGET4: MOVE TT,D
IDIVI D,50
JUMPE R,LDGET4
PUSHJ P,GETDD0
JRST LDGETX
] ;END OF IFN D10
LDGT5B: MOVEM TT,-4(FXP) ;WIN, WIN - USE RANDOM FXP SLOT
MOVEI A,-4(FXP) ; TO FAKE UP A FIXNUM
JRST LDGETJ
LDGETX: MOVEI A,(C)
PUSHJ P,NCONS
MOVEI B,QGETDDTSYM ;DO A FAIL-ACT
PUSHJ P,XCONS
PUSHJ P,LDGETQ
LDGETJ: POP FXP,F ;RESTORE ACS
POP FXP,R
POP FXP,D
POP FXP,AR1
PUSHJ P,LDLRSP ;LOCKI AND RESTORE ARRAY POINTERS
MOVE TT,(A)
PUSHJ P,TYPEP ;FIGURE OUT WHAT WE GOT BACK
POP FXP,-1(FXP) ;POP RANDOM SLOT (REMEMBER THE LOCKI!)
CAIN A,QFIXNUM
JRST LDGET1
LDGETV: CAIN A,QFLONUM ;USE A FLONUM IF WE GET ONE
JRST LDGET1
LDGETW: PUSHJ P,LDGDDT ;FOR ANYTHING ELSE TRY DDT AGAIN
MOVEM TT,LDDDTP(P)
JRST LDGET2
LDGET6: REPEAT 4,[<11←24.>+<<<3-.RPCNT>*11>←30.> LAP5P(R)
]
IFN ITS,[
LDGDDT: JSP T,SIDDTP
JRST ZPOPJ ;0 => TOP LEVEL, OR NOT INFERIOR TO DDT
.BREAK 12,[..RSTP,,TT] ;-1,,0 => INFERIOR TO DDT, BUT NO SYMBOL TABLE
SKIPN TT ;1,,0 => INFERIOR TO DDT WITH SYMBOL TABLE
TLOA TT,-1
MOVSI TT,1
POPJ P,
] ;END OF IFN ITS
IFN D10,[
LDGDDT: SKIPE TT,.JBSYM"
MOVSI TT,1
POPJ P,
] ;END OF IFN D10
LDXCT: MOVSS TT ;INDEX FIELD
HRRZS TT ;ADDRESS FIELD
LSH TT,23. ;AC FIELD
JFCL ;OPCODE FIELD
LDMASK: -1 ;INDEX FIELD
0,,-1 ;ADDRESS FIELD
0 17, ;AC FIELD
-1 ;OPCODE FIELD
LDLHRL: HRLZ TT,LDOFST
ADDM TT,-1(R)
JRST LDBIN
SUBTTL ARRAY, GLOBALSYM, AND ATOMTABLE ENTRY STUFF
LDAREF: PUSH FXP,TT ;[ARRAY REFERENCE]
MOVE D,@LDAPTR
TLNN D,777001
TLO D,11
MOVEM D,@LDAPTR
MOVEI A,(D)
PUSHJ P,TTSR+1 ;NCALL TO TTSR
HLL TT,(FXP)
SUB FXP,R70+1
JRST LDABS
LDGLB: SKIPL TT ;[GLOBALSYM PATCH]
SKIPA TT,LSYMS(TT) ;GET VALUE OF GLOBAL SYMBOL
MOVN TT,LSYMS(TT) ;OR MAYBE NEGATIVE THEREOF
ADD TT,-1(R) ;ADD TO ADDRESS FIELD OF
HRRM TT,-1(R) ; LAST WORD LOADED
JRST LDBIN
LDATM: LDB T,[410300,,TT] ;[ATOMTABLE ENTRY]
JRST LDATBL(T)
LDATBL: JRST LDATPN ;PNAME
JRST LDATFX ;FIXNUM
JRST LDATFL ;FLONUM
BG$ JRST LDATBN ;BIGNUM
BG% JRST LDATER
DB$ JRST LDATDB ;DOUBLE
DB% JRST LDATER
CX$ JRST LDATCX ;COMPLEX
CX% JRST LDATER
DX$ JRST LDATDX ;DUPLEX
DX% JRST LDATER
.VALUE ;UNDEFINED
LDATPN: MOVEI D,(TT) ;[ATOMTABLE PNAME ENTRY]
PUSH FXP,R
CAILE D,LPNBUF
JRST LDATP2
MOVEI C,PNBUF-1
LDATP1: JSP T,LDGTWD
ADDI C,1
MOVEM TT,(C)
SOJG D,LDATP1
SETOM LPNF
JRST LDATP4
LDATP2: PUSH FXP,D
LDATP3: JSP T,LDGTWD
JSP T,FWCONS
PUSH P,A
SOJG D,LDATP3
POP FXP,T
MOVNS T
JSP R,LIST1
SETZM LPNF
LDATP4: PUSH FXP,AR1
PUSHJ P,RINTERN
POP FXP,AR1
POP FXP,R
LDATP8: MOVE TT,LDAAOB
MOVEM A,@LDAPTR
AOBJP TT,LDAEXT
MOVEM TT,LDAAOB
JRST LDBIN
LDATFX: JSP T,LDGTWD ;[ATOMTABLE FIXNUM ENTRY]
PUSH FXP,TT
MOVEI A,(FXP)
PUSH P,AR1
PUSHJ P,GCLOOK
POP P,AR1
POP FXP,TT
SKIPE A
LDATX0: TLOA A,10
JRST LDATX2
LDATX1: TLO A,2
JRST LDATP8
LDATX2: SKIPE V.PURE
JRST LDATX3
JSP T,FXCONS
JRST LDATX1
LDATX3: PUSHJ P,PFXCONS
JRST LDATX0
LDATFL: JSP T,LDGTWD ;[ATOMTABLE FLONUM ENTRY]
PUSH FLP,TT
MOVEI A,(FLP)
PUSH P,AR1
PUSHJ P,GCLOOK
POP P,AR1
POP FLP,TT
SKIPE A
LDATL0: TLOA A,10
JRST LDATL2
LDATL1: TLO A,4
JRST LDATP8
LDATL2: SKIPE V.PURE
JRST LDATL3
JSP T,FLCONS
JRST LDATL1
LDATL3: PUSHJ P,PFLCONS
JRST LDATL0
IFN BIGNUM,[
LDATBN: PUSH FXP,TT ;[ATOMTABLE BIGNUM ENTRY]
MOVEI D,(TT)
MOVEI B,NIL
LDATB1: JSP T,LDGTWD
SKIPE V.PURE
JRST LDATB2
JSP T,FWCONS
PUSHJ P,CONS
JRST LDATB3
LDATB2: PUSHJ P,PFXCONS
PUSHJ P,PCONS
LDATB3: MOVE B,A
SOJG D,LDATB1
POP FXP,TT
TLNE TT,1
TLO A,-1
SKIPE V.PURE
JRST LDATB6
PUSHJ P,BNCONS
JRST LDATB7
LDATB6: PUSHJ P,PBNCONS
TLO A,10
LDATB7: TLO A,6
JRST LDATP8
] ;END OF IFN BIGNUM
LDAEXT: MOVE T,TT ;[ATOMTABLE EXTEND]
HRLI T,-ILDAT
MOVEM T,LDAAOB
ADDI TT,ILDAT
ASH TT,1
UNLOCKI .SEE ERROR5 ;.REARRAY MAY PULL AN ERINT
PUSH FXP,AR1
PUSH FXP,R
PUSH FXP,F
PUSH P,[LDRFRF]
PUSH P,LDASAR
PUSH P,[TRUTH]
PUSH FXP,TT
MOVEI A,(FXP)
PUSH P,A
MOVNI T,3
JRST .REARRAY
LDRFRF: SUB FXP,R70+1 ;[RETURN FROM .REARRAY FUNCTION]
POP FXP,F
POP FXP,R
POP FXP,AR1
PUSHJ P,LDLRSP
JRST LDBIN
SUBTTL ENTRY POINT
LDENT: HRRZ C,@LDAPTR ;[ENTRY POINT INFO]
MOVSS TT
HRRZ A,@LDAPTR
PUSH P,A
PUSH P,C
SKIPN B,VFASLOAD
JRST LDNRDF
PUSHJ P,GETLA
JUMPE A,LDNRDF
PUSH P,A
PUSH FXP,AR1
PUSH FXP,R
PUSH FXP,F
PUSHJ P,IOGBND
STRT [SIXBIT \↑M;CAUTION#! !\]
MOVE A,-2(P)
PUSHJ P,PRIN1
HRRZ B,@(P)
HLRZ B,(B)
MOVEI TT,[SIXBIT \, A SYSTEM !\]
10% CAIL B,ENDFUN
10$ CAIGE B,BEGFUN
MOVEI TT,[SIXBIT \, A USER !\]
STRT (TT)
HLRZ A,@(P)
PUSHJ P,PRIN1
HRRZ TT,@(P)
HLRZ TT,(TT)
MOVEI T,(TT)
LSH T,-SEGLOG
HRRZ T,ST(T)
CAIE T,QRANDOM
JRST LDENT4
STRT [SIXBIT \ AT !\] ;USE OF PRINL4 HERE DEPENDS ON PRIN1
PUSHJ P,PRINL4 ; LEAVING ADDRESS OF TYO IN R
LDENT4: STRT [SIXBIT \, IS BEING REDEFINED↑M; AS A !\]
HRRZ A,-1(P)
PUSHJ P,PRIN1
STRT [SIXBIT \ BY FASL FILE !\]
MOVE A,LDFNAM
PUSHJ P,PRIN1
PUSHJ P,TERPRI
PUSHJ P,UNBIND
POP FXP,F
POP FXP,R
POP FXP,AR1
SUB P,R70+1
LDNRDF: MOVE B,(P)
MOVE A,-1(P)
PUSHJ P,REMPROP
POP P,C
MOVE A,(P)
JSP T,LDGTWD
PUSH FXP,TT
MOVEI B,@LDOFST
CAILE B,(R)
JSP D,LDFERR
PUSHJ P,PUTPROP
POP FXP,TT
HLRZ T,TT
HLRZ B,@(P)
HLRZ D,1(B)
CAIN D,(T) ;NEEDN'T DO IT IF ALREADY SAME
JRST LDPRG3
LDPARG: ;ELSE TRY TO CLOBBER IT IN
PURTRAP LDPRG9,B, HRLM T,1(B)
LDPRG3: SUB P,R70+1
JRST LDBIN
SUBTTL PUTDDTSYM FROM FASL FILE
;;; THE WORD IN TT HAS SQUOZE FOR DEFINED SYMBOL, PLUS FOUR BITS:
;;; 4.9 1 => FOLLOWING WORD IS VALUE, 0 => LOAD LOC IS VALUE
;;; 4.8 LH IS RELOCATABLE
;;; 4.7 RH IS RELOCATABLE
;;; 4.6 IS GLOBAL (0 => SYMBOLS = 'T LOADS, BUT = 'SYMBOLS DOES NOT)
IFN ITS,[
LDPUT: SKIPN A,V$SYMBOLS
JRST LDPUT3 ;FORGET IT IF SYMBOLS NOT NON-NIL
CAIE A,Q$SYMBOLS
JRST LDPUT7
TLNN TT,40000 ;IF HAS 'SYMBOLS, LOAD ONLY GLOBALS
JRST LDPUT3
LDPUT7: JUMPL TT,LDPUT2
MOVEI D,(R)
LDPUT0: TLZ TT,740000
TLO TT,%SYGBL
SKIPG A,LDDDTP(P)
JRST LDBIN ;FORGET IT IF DDT HAS NO SYMBOL TABLE
MOVE T,TT
TRNE A,-1 ;MAY HAVE TO CREATE SYMBOL TABLE ARRAY
JRST LDPUT5
UNLOCKI
PUSH FXP,AR1
PUSHJ P,SAVX5
MOVEI TT,LLDSTB*2+1
MOVSI A,-1
PUSHJ P,MKFXAR
PUSHJ P,RSTX5
POP FXP,AR1
PUSHJ P,LDLRSP
HRRM A,LDDDTP(P)
LDPUT4: MOVSI TT,-LLDSTB ;USE TT FOR TWO THINGS HERE!
MOVEM TT,@TTSAR(A)
LDPUT5: SETZ TT,
AOS TT,@TTSAR(A) ;GET AOBJN POINTER
JUMPGE TT,LDPUT4
MOVEM T,@TTSAR(A) ;SAVE SQUOZE FOR SYMBOL
ADD TT,R70+1
MOVEM D,@TTSAR(A) ;SAVE ITS VALUE
MOVE T,TT
SETZ TT,
MOVEM T,@TTSAR(A) ;SAVE BACK INCREMENTED AOBJN PTR
JUMPL T,LDBIN
PUSHJ P,LDPUTM ;MAY BE TIME TO OUTPUT BUFFER
JRST LDBIN
LDPUTM: SETZ TT,
MOVN T,@TTSAR(A)
MOVSI T,(T)
HRR T,TTSAR(A)
AOSGE T
.BREAK 12,[..SSTB,,T]
POPJ P,
] ;END OF IFN ITS
IFN D10,[
LDPUT: SKIPN A,V$SYMBOLS
JRST LDPUT3
CAIE A,Q$SYMBOLS
JRST LDPUT7
TLNN TT,40000
JRST LDPUT3
LDPUT7: SKIPN .JBSYM"
JRST LDPUT3
PUSH FXP,AR1
JUMPL TT,LDPUT2
MOVE D,R
LDPUT0: PUSH FXP,D
PUSH FXP,F
TLZ TT,740000
LDPUT1: MOVE T,TT
IDIVI TT,50
JUMPE D,LDPUT1
MOVEI B,-1(FXP)
MOVSI R,400000
PUSHJ P,PUTDD0
POP FXP,F
SUB FXP,R70+1
POP FXP,R
POP FXP,AR1
JRST LDBIN
] ;END OF IFN D10
LDPUT2: MOVE D,TT
JSP T,LDGTWD
EXCH TT,D
TLNN TT,100000
JRST LDPT2A
MOVE T,LDOFST
ADD T,D
HRRM T,D
LDPT2A: TLNN TT,200000
JRST LDPT2B
HRLZ T,LDOFST
ADD D,T
LDPT2B: TLZ T,740000
TLO T,%SYGBL+%SYHKL ;GLOBAL AND HALF-KILLED
JRST LDPUT0
LDPUT3: JUMPGE TT,LDBIN ;DON'T WANT TO PUT DDT SYM, BUT
JSP T,LDGTWD ; MAYBE NEED TO FLUSH EXTRA WORD
JRST LDBIN
LDLOC: MOVEI TT,@LDOFST
MOVEI D,(R)
CAMLE D,LDHLOC
MOVEM D,LDHLOC
CAMG TT,LDHLOC
JRST LDLOC5
MOVE D,LDHLOC
SUBI D,(R)
MOVSI D,(D)
ADD R,D
HRR R,LDHLOC
SETZ TT,
SUB F,R70+1 ;BEWARE THIS BACK-UP CROCK!
ADD AR1,[040000,,]
JRST LDABS
LDLOC5: HRRZ D,LDOFST
CAIGE TT,(D)
JSP D,LDFERR
MOVEI D,(TT)
SUBI D,(R)
MOVSI D,(D)
ADD R,D
HRRI R,(TT)
JRST LDBIN
SUBTTL EVALUATE MUNGEABLE
LDEVAL: SETZ D, ;[EVALUATE MUNGEABLE]
PUSHJ P,LDLIST ;IF D IS LEFT 0 AFTER LDLIST, THEN WANT ENTRY INTO ATOMTABLE
MOVEI B,(P) ;B HAS ADDR OF FASLOAD TEMPS ON STACK
PUSH P,A
PUSHJ P,LDEV0
SUB P,R70+1
JUMPN D,LDBIN
JSP T,LDQLPRO ;PUSHES GOODY ONTO THE LDEVPRO LIST
LDEVL7: TLO A,16 ;AND GOES OFF TO ENTER INTO THE ATOMTABLE
JRST LDATP8
LDEV0: UNLOCKI ;EVALUATES AN S-EXPRESSION IN A
IFN QIO,[
JUMPE D,LDEV2 ;IN QIO, ALLOWS FOR RECURSIVE FASLOADING
SETZM FASLP ;EXCEPT WHEN EVALUATING FOR ENTRY INTO ATOMTABLE
PUSH P,A
MOVEI TT,(R)
JSP T,FXCONS
MOVEM A,VBPORG
MOVE A,LDPRLS(B)
TLNN A,600000
HRRZM A,VPURCLOBRL
HRRZ TT,LDOFST ;IN CASE EVALUATION CHANGES BPORG,
SUBI TT,(R) ; MUST CHANGE LDOFST TO BE AN
HRRM TT,LDOFST ; ABSOLUTE QUANTITY
MOVNI T,LFTMPS
PUSH FXP,BFTMPS+LFTMPS(T)
AOJL T,.-1
POP P,A
LDEV2:
] ;END OF IFN QIO
PUSH FXP,B
PUSH FXP,AR1
PUSH FXP,D
Q% PUSH FXP,R
PUSH FXP,F
PUSHJ P,EVAL
POP FXP,F
Q% POP FXP,R
POP FXP,D
POP FXP,AR1
POP FXP,B
IFN QIO,[
MOVE R,@VBPORG
JUMPE D,LDEV1
HRRZ T,LDBGEN(B)
MOVEM T,FASLP
MOVEI T,LFTMPS-1
POP FXP,BFTMPS(T)
SOJGE T,.-1
HRRZ TT,LDOFST ;NOW RE-RELOCATE THE LOAD OFFSET
ADD TT,@VBPORG
HRRM TT,LDOFST
HRRZ T,VPURCLOBRL
HRRM T,LDPRLS(B)
] ;END OF IFN QIO
LDEV1: PUSH P,A
PUSHJ P,LDGTSP
POP P,A
JRST LDLRSP ;GET SPACE, LOCKI, AND RESTORE PTRS
SUBTTL END OF FASLOAD FILE
LDBEND: TRZ TT,1 ;CROCK!
CAME TT,[SIXBIT \*FASL*\]
JSP D,LDFERR
MOVEI TT,LDFEND
MOVEM TT,LDEOFJ
IFN ITS,[
SKIPLE A,LDDDTP(P)
TRNN A,-1
CAIA
PUSHJ P,LDPUTM ;MAYBE HAVE TO FORCE LDPUT'S BUFFER
] ;END OF IFN ITS
HLLZS LDDDTP(P) ;WILL USE FOR SWITCH LATER
JSP T,LDGTWD
TRZ TT,1 ;COMPATIBILITY CROCK
CAME TT,[SIXBIT \*FASL*\]
JRST LDBEN1
HLLOS LDDDTP(P)
MOVEM F,LDTEMP
JRST LDFEND
LDBEN1: TRZ TT,1
CAME TT,[14060301406]
10% JSP D,LDFERR
10$ JUMPN TT,LDFERR
LDFEND: MOVEI TT,(R) ;END OF FILE
CAMGE R,LDHLOC
MOVE R,LDHLOC
JSP T,FWCONS
IFE ITS, MOVEM A,VBPORG ;UPDATE BPORG
IFN ITS,[
MOVE D,(A)
EXCH A,VBPORG
MOVE TT,(A)
SKIPL LDPRLS(P)
JRST LDZPUR
HLLOS NOQUIT
ANDI TT,PAGMSK
ANDI D,PAGMSK
LSHC TT,-PAGLOG
SUBI D,(TT)
ROT TT,-4
ADDI TT,(TT)
ROT TT,-1
TLC TT,770000
ADD TT,[450200,,PURTBL]
MOVEI T,1
LDNPUR: TLNN TT,730000
TLZ TT,770000
IDPB T,TT
SOJGE D,LDNPUR
PUSHJ P,CZECHI
LDZPUR:
] ;END OF IFN ITS
;FALLS THROUGH
;FALLS IN
PUSH FXP,F ;SAVE POINTER TO I/O BUFFER
HRRZ F,LDAAOB
LDGCPR: SOJLE F,LDSDPL ;[GC PROTECT AS YET UNPROTECTED ATOMS]
SKIPE INTFLG
PUSHJ P,LDTRYI
MOVEI TT,(F)
MOVE AR2A,@LDAPTR
HRRZ A,AR2A
JUMPE A,LDGCPR ;LOSING MIDAS!
TLNN AR2A,777000
TLNN AR2A,6
JRST LDGCP4
TLNN AR2A,10
TLNN AR2A,1
JRST LDGCPR
LDGCP1: HRRZ A,AR2A
CAIGE A,IN0+XHINUM
CAIGE A,IN0-XLONUM
PUSHJ P,%GCPRO ;IF FOR SOME REASON, THIS CAUSES THE CREATION OF THE GCPSAR
JRST LDGCPR ; I STILL DONT THINK WE NEED TO RESTORE PTRS HERE
LDGCP4: HLRZ B,(A) ;CONSIDER SETTING THE "COMPILED CODE
MOVE R,(B) ; NEEDS ME" BIT IN THE SYMBOL BLOCK
TLO R,100 ;SO FAR, SO GOOD
TLNN R,200 ;BUT CAN'T DO IT FOR A PURE BLOCK!
MOVEM R,(B)
JRST LDGCPR
SUBTTL SMASH DOWN PURE LIST
LDSDPL: SKIPL TT,LDPRLS(P) ;[SMASH DOWN PURE LIST]
TLNE TT,200000
JRST LDEOMM
MOVEM TT,VPURCLOBRL
MOVEI F,VPURCLOBRL
LDSDP1: SKIPN TT,LDPRLS(P)
JRST LDEOMM
SKIPN INTFLG
JRST LDSDP2
SKIPE INTFLG
PUSHJ P,LDTRYI
LDSDP2: HRRZ T,(TT)
MOVEM T,LDPRLS(P)
HLRZ AR2A,(TT)
PUSHJ P,LDSMSH
JRST LDSDP3
HRRZ F,(F)
JRST LDSDP1
LDSDP3: MOVE TT,LDPRLS(P)
HRRM TT,(F)
JRST LDSDP1
SUBTTL END OF FASLOAD, AND RANDOM ROUTINES
LDEOMM: POP FXP,LDTEMP ;GET POINTER TO I/O BUFFER
MOVE TT,LDDDTP(P)
Q$ MOVE A,LDBGEN(P)
SUB P,R70+LDNPDS ;[END OF MOBY MESS!!!]
TRNE TT,-1
JRST LDEOM1
Q$ PUSHJ P,$CLOSE ;CLOSE FILE ARRAY
Q% 10% .CLOSE DSIC,
Q% 10$ RELEASE DSIC,
MOVE A,VBPORG
UNLOCKI
PUSHJ P,UNBIND
HRRZ TT,-2(P) ;FOR DEBUGGING PURPI,
HRRZ D,-1(P) ; MAKE SURE PDLS ARE OKAY
HRRZ R,(P)
SUB P,R70+3
JRST PDLCHK
LDEOM1: UNLOCKI
Q$ PUSH P,A ;PUT LDBSAR BACK ON PDL
JRST LDDISM
LDTRYI: UNLOCKI ;[TRY AN INTERRUPT]
LDLRSP: LOCKI ;[LOCKI AND RESTORE POINTERS]
LDRSPT: HRRZ TT,LDASAR ;[RESTORE ARRAY POINTERS]
HRRZ TT,TTSAR(TT)
HRRM TT,LDAPTR
HRRZ TT,LDBSAR
HRRZ TT,TTSAR(TT)
HRRM TT,LDBPTR
POPJ P,
LDLIST: MOVEI C,-1(P) .SEE LDOWL
JRST LDLIS1
LDLIS0: JSP T,LDGTWD
LDLIS1: LDB T,[410300,,TT] ;[CONSTRUCT LIST]
JRST LDLTBL(T)
LDLTBL: JRST LDLATM ;ATOM
JRST LDLLST ;LIST
JRST LDLDLS ;DOTTED LIST
JRST LDOWL ;EVALUATE TOP FROB ON STACK
IFN HNKLOG, JRST LDLHNK ;HUNK
.ELSE JRST FASHNE
REPEAT 2, .VALUE
JRST LDLEND ;END OF LIST
LDLATM: MOVE A,@LDAPTR ;FOR ATOM, MAYBE SET USAGE BIT,
TLNN A,777011 ; THEN SHOVE ON STACK
IOR A,D
MOVEM A,@LDAPTR
PUSH P,A
JRST LDLIS0
LDLLST: TDZA A,A ;FOR LIST, USE NIL AS END
LDLDLS: POP P,A ;FOR DOTTED LIST, USE TOP ITEM
HRRZS TT
JUMPE TT,LDLLS3
LDLLS1: POP P,B ;NOW POP N THINGS AND CONS THEM UP
PUSHJ P,XCONS
SOJG TT,LDLLS1
LDLLS3: PUSH P,A
SKIPE INTFLG
PUSHJ P,LDTRYI
JRST LDLIS0
LDOWL: MOVE A,(P)
MOVEI B,(C) ;B HAS ADDR OF FASLOAD TEMPS ON STACK
PUSH P,C
PUSHJ P,LDEV0
POP P,C
MOVEM A,(P)
JRST LDLIS0
IFN HNKLOG,[
LDLHNK: MOVEI T,-1(TT)
JSP AR2A,HUNKF0 ;SAVES C
PUSH P,A
JRST LDLIS0
] ;END OF IFN HNKLOG
LDLEND: HLRZ D,TT
TRC D,777776
TRNE D,777776
JSP D,LDFERR
POP P,A
MOVSS TT
HRRI TT,(A)
POPJ P,
;;; SECOND FILE NAME OF THIS LISP WHEN ASSEMBLED (VERSION NUMBER
;;; THIS LOCATION IS REFERENCED BY FASLAP WHEN CREATING A BINARY
;;; FILE. IT CONTAINS THE VALUE OF .FNAM2 PLUS EXTRA BITS
;;; TO DISTINGUISH SOME CONDITIONAL ASSEMBLY FLAGS.
;;; THE CONTENTS OF THIS LOCATION ARE PRIMARILY USED TO DETERMINE
;;; WHETHER FASLOAD MAY USE VALUES OF DDT SYMBOLS SUPPLIED BY
;;; FASLAP; IT DOES SO ONLY IF FASLAP'S VERSION NUMBER, AS
;;; DETERMINED BY THIS LOCATION, IS THE SAME AS FASLOAD'S.
ZZ==-1
ZZZ==0
;;; BIBOP USED TO BE THE 3RD NUMBER HERE
IRP X,,[D10,ML,1,BIGNUM,MOBIOF]
ZZ==ZZ←1
ZZZ==<ZZZ←1>\X
TERMIN
LDFNM2: <.FNAM2&ZZ>\ZZZ
EXPUNGE ZZ ZZZ
IFE QIO,[
LDFNSET: MOVE A,LDFNAM
JSP T,LNG1A ;GETS LENGTH OF ARG
MOVE A,LDFNAM
CAIN TT,4
POPJ P,
CAIGE TT,2
JRST SCRFUN ;COMPUTES STANDARD FILE SPECIFICATION LIST
JSP T,%CADR ;FROM INPUT ARG
MOVE B,IUNIT
PUSHJ P,CONS
HLRZ B,@LDFNAM
JRST XCONS
] ;END OF IFE QIO
IFE QIO,[
LDGTW0: HRLZI F,-LLDBF ;RESET THE POINTER AND THIS TIME GET A REAL DATA WORD
LDGTWD: MOVE TT,@LDBPTR ;PICK UP WORD FROM INPUT BUFFER
AOBJN F,(T) ;RETURN WITH WORD
LDGTW1: MOVE F,@LDBSAR .SEE ASAR
MOVE F,-1(F) ;THAT WAS NO DATA WORD - MUST GET MORE
IFN ITS,[
ADD F,[1,,]
MOVE TT,F
.IOT DSIC,F
TLNN F,-1 ;SKIP IF WE DIDNT GET A WHOLE BUFFERFUL
JRST LDGTW0
CAMN F,TT ;SKIP IF WE GOT AT LEAST ONE WORD
JSP D,@LDEOFJ ;OTHERWISE GO CRY A LOT, OR SOMETHING
HLRES F ;CALCULATE POINTER FOR THE PARTIAL BLOCK
ADDI F,LLDBF
MOVNS F
HRLZS F
JRST LDGTWD ;NOW GO GET A REAL DATA WORD
] ;END OF IFN ITS
IFN D10,[
ADDI F,-1 ;SIMULTANEOUS +1 IN LH -1 IN RH
MOVEM F,D10ARD ;SAVE IN I/O LIST
IFN SAIL,[
PUSH FXP,D
PUSH FXP,R
HRRZ D,D10ARD
AOJ D, ;D10ARD POINTS TO ADDRESS BEFORE
HRLI D,-1(D)
AOBJN D,.+1 ;CONS UP BLT PTR
SETZM -1(D) ;ZERO FIRST WORD
MOVEI R,200-1(D) ;CALCULATE END-WORD ADDR
BLT D,(R) ;BLLLLLLLLLLLLLLLLLLLL. . .LLLLLT
POP FXP,R
POP FXP,D
] ;END OF IFN SAIL
SA% IN DSIC,D10ARD
SA$ JSP F,SAIFCA ;THIS IS THE SAIL DUMP MODE CACHE HACK
JRST LDGTW0
IFN SAIL,[
SKIPE SAILFL ;FLAG SET?
JRST .+3 ;NO, THEN WE GOT STUFF FROM DSK
AOS SAILFL ;YES, SET FLAG IN CASE WE ASK FOR MORE LATER
JRST LDGTW0
] ;END OF IFN SAIL
JSP D,@LDEOFJ
SAIFCA: PUSH FXP,A ;SAVE SOME REGISTERS FOR GENERAL USE
PUSH FXP,D ;WE NEED 3
PUSH FXP,R
SKIPE SAIFN ;ARE THERE ANY VALID BUFFERS?
JRST SAIFBF ;YES, RETURN THE NEXT ONE
HRRZI D,SAIFBF ;NO, SO WE ZERO OUT THE CACHE
HRLI D,-1(D)
AOBJN D,.+1
SETZM -1(D)
MOVEI R,<200*SAIFBN>-1(D)
BLT D,(R) ;BLT ALL ZEROS IN
SETZM SAIFSK ;SET SKIP RETURN FLAG TO ZERO
IN 6,SAIFDW ;DUMP MODE IN SAIFBN BUFFERS FULL
JRST .+2 ;SUCCESS RETURN
SETOM SAIFSK
MOVEI D,SAIFBN
MOVEM D,SAIFBP
] ;END OF IFN SAIL
] ;END OF IFN D10
] ;END OF IFE QIO
IFN QIO,[
LDGTW0: MOVE F,[-XDIB.BS,,FB.BUF]
LDGTWD: MOVE TT,@LDBPTR
AOBJN F,(T)
LDGTW1: HRRZ TT,LDBSAR
HRRZ TT,TTSAR(TT)
MOVE F,FB.IOT(TT)
ADD F,[1,,]
.CALL LDGTW9
.VALUE
TLNN F,-1
JRST LDGTW0
SUB F,[1,,]
CAMN F,FB.IOT(TT)
JSP D,@LDEOFJ
HLRZ TT,FB.IOT(TT)
HLRES F
SUBI F,-1(TT)
MOVNS F
HRLZS F
HRRI F,FB.BUF
JRST LDGTWD
LDGTW9: SETZ
SIXBIT \IOT\ ;I/O TRANSFER
,,F.CHAN(TT) ;CHANNEL #
400000,,F ;BLOCK POINTER
] ;END OF IFN QIO
PGTOP FSL,[FASLOAD]